home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / mule / mule-ccl.el.z / mule-ccl.el
Encoding:
Text File  |  1998-05-21  |  22.1 KB  |  697 lines
  1. ;;; mule-ccl.el --- Code Conversion Language functions.
  2.  
  3. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  4.  
  5. ;; This file is part of XEmacs.
  6.  
  7. ;; XEmacs is free software; you can redistribute it and/or modify it
  8. ;; under the terms of the GNU General Public License as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11.  
  12. ;; XEmacs is distributed in the hope that it will be useful, but
  13. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;; General Public License for more details.
  16.  
  17. ;; You should have received a copy of the GNU General Public License
  18. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  19. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20. ;; Boston, MA 02111-1307, USA.
  21.  
  22. ;;; 93.5.26  created for Mule Ver.0.9.8 by K.Handa <handa@etl.go.jp>
  23.  
  24. ;;;; #### This stuff doesn't work yet.
  25.  
  26. (defconst ccl-operator-table
  27.   '[if branch loop break repeat write-repeat write-read-repeat
  28.     read read-if read-branch write end])
  29.  
  30. (let (op (i 0) (len (length ccl-operator-table)))
  31.   (while (< i len)
  32.     (setq op (aref ccl-operator-table i))
  33.     (put op 'ccl-compile-function (intern (format "ccl-compile-%s" op)))
  34.     (setq i (1+ i))))
  35.  
  36. (defconst ccl-machine-code-table
  37.   '[set-cs set-cl set-r set-a
  38.     jump jump-cond write-jump write-read-jump write-c-jump
  39.     write-c-read-jump write-s-jump write-s-read-jump write-a-read-jump
  40.     branch
  41.     read1 read2 read-branch write1 write2 write-c write-s write-a
  42.     end
  43.     set-self-cs set-self-cl set-self-r set-expr-cl set-expr-r
  44.     jump-cond-c jump-cond-r read-jump-cond-c read-jump-cond-r
  45.     ])
  46.  
  47. (let (code (i 0) (len (length ccl-machine-code-table)))
  48.   (while (< i len)
  49.     (setq code (aref ccl-machine-code-table i))
  50.     (put code 'ccl-code i)
  51.     (put code 'ccl-dump-function (intern (format "ccl-dump-%s" code)))
  52.     (setq i (1+ i))))
  53.  
  54. (defconst ccl-register-table '[r0 r1 r2 r3 r4 r5 r6 r7])
  55.  
  56. (let (reg (i 0) (len (length ccl-register-table)))
  57.   (while (< i len)
  58.     (setq reg (aref ccl-register-table i))
  59.     (put reg 'ccl-register-number i)
  60.     (setq i (1+ i))))
  61.  
  62. (defconst ccl-arith-table
  63.   '[+ - * / % & | ^ << >> <8 >8 // nil nil nil < > == <= >= !=])
  64.  
  65. (let (arith (i 0) (len (length ccl-arith-table)))
  66.   (while (< i len)
  67.     (setq arith (aref ccl-arith-table i))
  68.     (if arith (put arith 'ccl-arith-code i))
  69.     (setq i (1+ i))))
  70.  
  71. (defconst ccl-self-arith-table
  72.   '[+= -= *= /= %= &= |= ^= <<= >>= <8= >8= //=])
  73.  
  74. (let (arith (i 0) (len (length ccl-self-arith-table)))
  75.   (while (< i len)
  76.     (setq arith (aref ccl-self-arith-table i))
  77.     (put arith 'ccl-self-arith-code i)
  78.     (setq i (1+ i))))
  79.  
  80. ;; this holds the compiled CCL program as it is being compiled.
  81. (defvar ccl-program-vector nil)
  82.  
  83. ;; this holds the index into ccl-program-vector where the next
  84. ;; instruction is to be stored.
  85. (defvar ccl-current-ic 0)
  86.  
  87. ;; add a constant to the compiled CCL program, either at IC (if specified)
  88. ;; or at the current instruction counter (and bumping that value)
  89. (defun ccl-embed-const (const &optional ic)
  90.   (if ic
  91.       (aset ccl-program-vector ic const)
  92.     (aset ccl-program-vector ccl-current-ic const)
  93.     (setq ccl-current-ic (1+ ccl-current-ic))))
  94.  
  95. (defun ccl-embed-code (op reg const &optional ic)
  96.   (let ((machine-code (logior (get op 'ccl-code)
  97.                   (if (symbolp reg)
  98.                   (ash (get reg 'ccl-register-number) 5)
  99.                 0)
  100.                   (ash const 8))))
  101.     (if ic
  102.     (aset ccl-program-vector ic machine-code)
  103.       (aset ccl-program-vector ccl-current-ic machine-code)
  104.       (setq ccl-current-ic (1+ ccl-current-ic)))))
  105.  
  106. ;; advance the instruction counter by INC without doing anything else
  107. (defun ccl-embed-nop (&optional inc)
  108.   (setq ccl-current-ic (+ ccl-current-ic (or inc 1))))
  109.  
  110. ;;;###autoload
  111. (defun ccl-program-p (obj)
  112.   "T if OBJECT is a valid CCL compiled code."
  113.   (and (vectorp obj)
  114.        (let ((i 0) (len (length obj)) (flag t))
  115.      (if (> len 1)
  116.          (progn
  117.            (while (and flag (< i len))
  118.          (setq flag (integerp (aref obj i)))
  119.          (setq i (1+ i)))
  120.            flag)))))
  121.  
  122. (defvar ccl-loop-head nil)
  123. (defvar ccl-breaks nil)
  124.  
  125. ;;;###autoload
  126. (defun ccl-compile (ccl-program)
  127.   "Compile a CCL source program and return the compiled equivalent.
  128. The return value will be a vector of integers."
  129.   (if (or (null (consp ccl-program))
  130.       (null (listp (car ccl-program))))
  131.       (error "CCL: Invalid source program: %s" ccl-program))
  132.   (if (null (vectorp ccl-program-vector))
  133.       (setq ccl-program-vector (make-vector 8192 0))
  134.     ;; perhaps not necessary but guarantees some sort of determinism
  135.     (fillarray ccl-program-vector 0))
  136.   (setq ccl-loop-head nil ccl-breaks nil)
  137.   (setq ccl-current-ic 0)
  138.   ;; leave space for offset to EOL program
  139.   (ccl-embed-nop)
  140.   (ccl-compile-1 (car ccl-program))
  141.   ;; store offset to EOL program in first word of compiled prog
  142.   (ccl-embed-const ccl-current-ic 0)
  143.   (if (car (cdr ccl-program))
  144.       (ccl-compile-1 (car (cdr ccl-program))))
  145.   (ccl-embed-code 'end 0 0)
  146.   (let ((vec (make-vector ccl-current-ic 0))
  147.     (i 0))
  148.     (while (< i ccl-current-ic)
  149.       (aset vec i (aref ccl-program-vector i))
  150.       (setq i (1+ i)))
  151.     vec))
  152.  
  153. (defun ccl-check-constant (arg cmd)
  154.   (if (>= arg 0)
  155.       arg
  156.     (error "CCL: Negative constant %s not allowed: %s" arg cmd)))
  157.  
  158. (defun ccl-check-register (arg cmd)
  159.   (if (get arg 'ccl-register-number)
  160.       arg
  161.     (error "CCL: Invalid register %s: %s" arg cmd)))
  162.  
  163. (defun ccl-check-reg-const (arg cmd)
  164.   (if (integer-or-char-p arg)
  165.       (ccl-check-constant arg cmd)
  166.     (ccl-check-register arg cmd)))
  167.  
  168. (defun ccl-check-compile-function (arg cmd)
  169.   (or (get arg 'ccl-compile-function)
  170.       (error "CCL: Invalid command: %s" cmd)))
  171.  
  172. ;; compile a block of CCL code (see CCL_BLOCK above).
  173. (defun ccl-compile-1 (cmd-list)
  174.   (let (cmd)
  175.     ;; a CCL_BLOCK is either STATEMENT or (STATEMENT [STATEMENT ...])
  176.     ;; convert the former into the latter.
  177.     (if (or (not (listp cmd-list))
  178.         (and cmd-list (symbolp (car cmd-list))))
  179.     (setq cmd-list (list cmd-list)))
  180.     (while cmd-list
  181.       (setq cmd (car cmd-list))
  182.       ;; an int-or-char is equivalent to (r0 = int-or-char)
  183.       ;; a string is equivalent to (write string)
  184.       ;; convert the above two into their equivalent forms.
  185.       ;; everything else is a list.
  186.       (cond ((integer-or-char-p cmd)
  187.          (ccl-compile-set (list 'r0 '= cmd)))
  188.         ((stringp cmd)
  189.          (ccl-compile-write-string (list 'write cmd)))
  190.         ((listp cmd)
  191.          (if (eq (nth 1 cmd) '=)
  192.          (ccl-compile-set cmd)
  193.            (if (and (symbolp (nth 1 cmd))
  194.             (get (nth 1 cmd) 'ccl-self-arith-code))
  195.            (ccl-compile-self-set cmd)
  196.          (funcall (ccl-check-compile-function (car cmd) cmd) cmd))))
  197.         (t
  198.          (error "CCL: Invalid command: %s" cmd)))
  199.       (setq cmd-list (cdr cmd-list)))))
  200.  
  201. (defun ccl-compile-set (cmd)
  202.   (let ((rrr (ccl-check-register (car cmd) cmd))
  203.     (right (nth 2 cmd)))
  204.     (cond ((listp right)
  205.        ;; cmd == (RRR = (XXX OP YYY))
  206.        (ccl-compile-expression rrr right))
  207.       ((integer-or-char-p right)
  208.        (ccl-check-constant right cmd)
  209.        (if (< right 524288)        ; (< right 2^19)
  210.            (ccl-embed-code 'set-cs rrr right)
  211.          (ccl-embed-code 'set-cl rrr 0)
  212.          (ccl-embed-const right)))
  213.       (t
  214.        (ccl-check-register right cmd)
  215.        (let ((ary (nth 3 cmd)))
  216.          (if (vectorp ary)
  217.          (let ((i 0) (len (length ary)))
  218.            (ccl-embed-code 'set-a rrr (get right 'ccl-register-number))
  219.            (ccl-embed-const len)
  220.            (while (< i len)
  221.              (ccl-check-constant (aref ary i) cmd)
  222.              (ccl-embed-const (aref ary i))
  223.              (setq i (1+ i))))
  224.            (ccl-embed-code 'set-r rrr right)))))))
  225.  
  226. (defun ccl-compile-self-set (cmd)
  227.   (let ((rrr (ccl-check-register (car cmd) cmd))
  228.     (right (nth 2 cmd)))
  229.     (if (listp right)
  230.     ;; cmd == (RRR SELF-OP= (XXX OP YYY))
  231.     (progn
  232.       (ccl-compile-expression 'r7 right)
  233.       (setq right 'r7)))
  234.     (ccl-compile-expression
  235.      rrr
  236.      (list rrr (intern (substring (symbol-name (nth 1 cmd)) 0 -1)) right))))
  237.  
  238. (defun ccl-compile-expression (rrr expr)
  239.   (let ((left (car expr))
  240.     (right (nth 2 expr)))
  241.     (if (listp left)
  242.     (progn
  243.       (ccl-compile-expression 'r7 left)
  244.       (setq left 'r7)))
  245.     (if (eq rrr left)
  246.     (if (integer-or-char-p right)
  247.         (if (< right 32768)
  248.         (ccl-embed-code 'set-self-cs rrr right)
  249.           (ccl-embed-code 'set-self-cl rrr 0)
  250.           (ccl-embed-const right))
  251.       (ccl-check-register right expr)
  252.       (ccl-embed-code 'set-self-r rrr (get right 'ccl-register-number)))
  253.       (if (integer-or-char-p right)
  254.       (progn
  255.         (ccl-embed-code 'set-expr-cl rrr (get left 'ccl-register-number))
  256.         (ccl-embed-const right))
  257.     (ccl-check-register right expr)
  258.     (ccl-embed-code 'set-expr-r rrr (get left 'ccl-register-number))
  259.     (ccl-embed-const (get right 'ccl-register-number))))
  260.     (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code))))
  261.  
  262. (defun ccl-compile-write-string (cmd)
  263.   (if (/= (length cmd) 2)
  264.       (error "CCL: Invalid number of arguments: %s" cmd))
  265.   (let* ((str (nth 1 cmd))
  266.      (len (length str))
  267.      (i 0))
  268.     (ccl-embed-code 'write-s 0 0)
  269.     (ccl-embed-const len)
  270.     (while (< i len)
  271.       (ccl-embed-const (aref str i))
  272.       (setq i (1+ i)))))
  273.  
  274. (defun ccl-compile-if (cmd)
  275.   (if (and (/= (length cmd) 3) (/= (length cmd) 4))
  276.       (error "CCL: Invalid number of arguments: %s" cmd))
  277.   (let ((condition (nth 1 cmd))
  278.     (true-cmds (nth 2 cmd))
  279.     (false-cmds (nth 3 cmd))
  280.     ic0 ic1 ic2)
  281.     (if (listp condition)
  282.     ;; cmd == (if (XXX OP YYY) ...)
  283.     (if (listp (car condition))
  284.         ;; cmd == (if ((xxx op yyy) OP YYY) ...)
  285.         (progn
  286.           (ccl-compile-expression 'r7 (car condition))
  287.           (setq condition (cons 'r7 (cdr condition)))
  288.           (setq cmd (cons (car cmd)
  289.                   (cons condition
  290.                     (cdr (cdr cmd))))))))
  291.     (setq ic0 ccl-current-ic)
  292.     (ccl-embed-nop (if (listp condition) 3 1))
  293.     (ccl-compile-1 true-cmds)
  294.     (if (null false-cmds)
  295.     (setq ic1 ccl-current-ic)
  296.       (setq ic2 ccl-current-ic)
  297.       (ccl-embed-const 0)
  298.       (setq ic1 ccl-current-ic)
  299.       (ccl-compile-1 false-cmds)
  300.       (ccl-embed-code 'jump 0 ccl-current-ic ic2))
  301.     (if (symbolp condition)
  302.     (ccl-embed-code 'jump-cond condition ic1 ic0)
  303.       (let ((arg (nth 2 condition)))
  304.     (if (integer-or-char-p arg)
  305.         (progn
  306.           (ccl-embed-code 'jump-cond-c (car condition) ic1 ic0)
  307.           (ccl-embed-const arg (1+ ic0)))
  308.       (ccl-check-register arg cmd)
  309.       (ccl-embed-code 'jump-cond-r (car condition) ic1 ic0)
  310.       (ccl-embed-const (get arg 'ccl-register-number) (1+ ic0)))
  311.     (ccl-embed-const (get (nth 1 condition) 'ccl-arith-code) (+ ic0 2))))))
  312.  
  313. (defun ccl-compile-branch (cmd)
  314.   (if (< (length cmd) 3)
  315.       (error "CCL: Invalid number of arguments: %s" cmd))
  316.   (if (listp (nth 1 cmd))
  317.       (progn
  318.     (ccl-compile-expression 'r7 (nth 1 cmd))
  319.     (setq cmd (cons (car cmd)
  320.             (cons 'r7 (cdr (cdr cmd)))))))
  321.   (ccl-compile-branch-1 cmd))
  322.  
  323. (defun ccl-compile-read-branch (cmd)
  324.   (ccl-compile-branch-1 cmd))
  325.  
  326. (defun ccl-compile-branch-1 (cmd)
  327.   (if (< (length cmd) 3)
  328.       (error "CCL: Invalid number of arguments: %s" cmd))
  329.   (let ((rrr (ccl-check-register (car (cdr cmd)) cmd))
  330.     (branches (cdr (cdr cmd)))
  331.     i ic0 ic1 ic2
  332.     branch-tails)
  333.     (ccl-embed-code (car cmd) rrr (- (length cmd) 2))
  334.     (setq ic0 ccl-current-ic)
  335.     (ccl-embed-nop (1- (length cmd)))
  336.     (setq i 0)
  337.     (while branches
  338.       (ccl-embed-const ccl-current-ic (+ ic0 i))
  339.       (ccl-compile-1 (car branches))
  340.       (setq branch-tails (cons ccl-current-ic branch-tails))
  341.       (ccl-embed-nop)
  342.       (setq i (1+ i))
  343.       (setq branches (cdr branches)))
  344.     ;; We don't need `jump' from the last branch.
  345.     (setq branch-tails (cdr branch-tails))
  346.     (setq ccl-current-ic (1- ccl-current-ic))
  347.     (while branch-tails
  348.       (ccl-embed-code 'jump 0 ccl-current-ic (car branch-tails))
  349.       (setq branch-tails (cdr branch-tails)))
  350.     ;; This is the case `rrr' is out of range.
  351.     (ccl-embed-const ccl-current-ic (+ ic0 i))
  352.     ))
  353.  
  354. (defun ccl-compile-loop (cmd)
  355.   (if (< (length cmd) 2)
  356.       (error "CCL: Invalid number of arguments: %s" cmd))
  357.   (let ((ccl-loop-head ccl-current-ic)
  358.     (ccl-breaks nil))
  359.     (setq cmd (cdr cmd))
  360.     (while cmd
  361.       (ccl-compile-1 (car cmd))
  362.       (setq cmd (cdr cmd)))
  363.     (while ccl-breaks
  364.       (ccl-embed-code 'jump 0 ccl-current-ic (car ccl-breaks))
  365.       (setq ccl-breaks (cdr ccl-breaks)))))
  366.  
  367. (defun ccl-compile-break (cmd)
  368.   (if (/= (length cmd) 1)
  369.       (error "CCL: Invalid number of arguments: %s" cmd))
  370.   (if (null ccl-loop-head)
  371.       (error "CCL: No outer loop: %s" cmd))
  372.   (setq ccl-breaks (cons ccl-current-ic ccl-breaks))
  373.   (ccl-embed-nop))
  374.  
  375. (defun ccl-compile-repeat (cmd)
  376.   (if (/= (length cmd) 1)
  377.       (error "CCL: Invalid number of arguments: %s" cmd))
  378.   (if (null ccl-loop-head)
  379.       (error "CCL: No outer loop: %s" cmd))
  380.   (ccl-embed-code 'jump 0 ccl-loop-head))
  381.  
  382. (defun ccl-compile-write-repeat (cmd)
  383.   (if (/= (length cmd) 2)
  384.       (error "CCL: Invalid number of arguments: %s" cmd))
  385.   (if (null ccl-loop-head)
  386.       (error "CCL: No outer loop: %s" cmd))
  387.   (let ((arg (nth 1 cmd)))
  388.     (cond ((integer-or-char-p arg)
  389.        (ccl-embed-code 'write-c-jump 0 ccl-loop-head)
  390.        (ccl-embed-const arg))
  391.       ((stringp arg)
  392.        (ccl-embed-code 'write-s-jump 0 ccl-loop-head)
  393.        (let ((i 0) (len (length arg)))
  394.          (ccl-embed-const (length arg))
  395.          (while (< i len)
  396.            (ccl-embed-const (aref arg i))
  397.            (setq i (1+ i)))))
  398.       (t
  399.        (ccl-check-register arg cmd)
  400.        (ccl-embed-code 'write-jump arg ccl-loop-head)))))
  401.  
  402. (defun ccl-compile-write-read-repeat (cmd)
  403.   (if (or (< (length cmd) 2) (> (length cmd) 3))
  404.       (error "CCL: Invalid number of arguments: %s" cmd))
  405.   (if (null ccl-loop-head)
  406.       (error "CCL: No outer loop: %s" cmd))
  407.   (let ((rrr (ccl-check-register (nth 1 cmd) cmd))
  408.     (arg (nth 2 cmd)))
  409.     (cond ((null arg)
  410.        (ccl-embed-code 'write-read-jump rrr ccl-loop-head))
  411.       ((integer-or-char-p arg)
  412.        (ccl-embed-code 'write-c-read-jump rrr ccl-loop-head)
  413.        (ccl-embed-const arg))
  414.       ((or (stringp arg) (vectorp arg))
  415.        (ccl-embed-code (if (stringp arg)
  416.                    'write-s-read-jump
  417.                  'write-a-read-jump)
  418.                rrr ccl-loop-head)
  419.        (let ((i 0) (len (length arg)))
  420.          (ccl-embed-const (length arg))
  421.          (while (< i len)
  422.            (ccl-embed-const (aref arg i))
  423.            (setq i (1+ i)))))
  424.       (t (error "CCL: Invalide argument %s: %s" arg cmd)))))
  425.                 
  426. (defun ccl-compile-read (cmd)
  427.   (let ((rrr (ccl-check-register (nth 1 cmd) cmd)))
  428.     (cond ((= (length cmd) 2)
  429.        (ccl-embed-code 'read1 rrr 0))
  430.       ((= (length cmd) 3)
  431.        (ccl-embed-code 'read2 rrr (get (nth 2 cmd) 'ccl-register-number)))
  432.       (t (error "CCL: Invalid number of arguments: %s" cmd)))))
  433.  
  434. (defun ccl-compile-read-if (cmd)
  435.   (if (and (/= (length cmd) 3) (/= (length cmd) 4))
  436.       (error "CCL: Invalid number of arguments: %s" cmd))
  437.   (let* ((expr (nth 1 cmd))
  438.      (rrr (ccl-check-register (car expr) cmd))
  439.      (true-cmds (nth 2 cmd))
  440.      (false-cmds (nth 3 cmd))
  441.      ic0 ic1 ic2)
  442.     (setq ic0 ccl-current-ic)
  443.     (ccl-embed-nop 3)
  444.     (ccl-compile-1 true-cmds)
  445.     (if (null false-cmds)
  446.     (setq ic1 ccl-current-ic)
  447.       (setq ic2 ccl-current-ic)
  448.       (ccl-embed-const 0)
  449.       (setq ic1 ccl-current-ic)
  450.       (ccl-compile-1 false-cmds)
  451.       (ccl-embed-code 'jump 0 ccl-current-ic ic2))
  452.     (let ((arg (nth 2 expr)))
  453.       (ccl-embed-code (if (integer-or-char-p arg) 'read-jump-cond-c
  454.             'read-jump-cond-r)
  455.               rrr ic1 ic0)
  456.       (ccl-embed-const (if (integer-or-char-p arg) arg
  457.              (get arg 'ccl-register-number))
  458.                (1+ ic0))
  459.       (ccl-embed-const (get (nth 1 expr) 'ccl-arith-code) (+ ic0 2)))))
  460.  
  461. (defun ccl-compile-write (cmd)
  462.   (if (and (/= (length cmd) 2) (/= (length cmd) 3))
  463.       (error "CCL: Invalid number of arguments: %s" cmd))
  464.   (let ((rrr (nth 1 cmd)))
  465.     (cond ((integer-or-char-p rrr)
  466.        (ccl-embed-code 'write-c 0 0)
  467.        (ccl-embed-const rrr))
  468.       ((stringp rrr)
  469.        (ccl-compile-write-string (list 'write rrr)))
  470.       (t
  471.        (ccl-check-register rrr cmd)
  472.        (let ((arg (nth 2 cmd)))
  473.          (if arg
  474.          (cond ((symbolp arg)
  475.             (ccl-check-register arg cmd)
  476.             (ccl-embed-code 'write2 rrr
  477.                     (get arg 'ccl-register-number)))
  478.                ((vectorp arg)
  479.             (let ((i 0) (len (length arg)))
  480.               (ccl-embed-code 'write-a rrr 0)
  481.               (ccl-embed-const len)
  482.               (while (< i len)
  483.                 (ccl-embed-const (aref arg i))
  484.                 (setq i (1+ i)))))
  485.                (t (error "CCL: Invalid argument %s: %s" arg cmd)))
  486.            (ccl-embed-code 'write1 rrr 0)))))))
  487.  
  488. (defun ccl-compile-end (cmd)
  489.   (if (/= (length cmd) 1)
  490.       (error "CCL: Invalid number of arguments: %s" cmd))
  491.   (ccl-embed-code 'end 0 0))
  492.  
  493. ;;; CCL dump staffs
  494. (defvar ccl-program-vector-dump nil)
  495.  
  496. ;;;###autoload
  497. (defun ccl-dump (ccl-code)
  498.   "Disassemble compiled CCL-CODE."
  499.   (save-excursion
  500.     (set-buffer (get-buffer-create "*CCL-Dump*"))
  501.     (erase-buffer)
  502.     (setq ccl-program-vector-dump ccl-code)
  503.     (let ((len (length ccl-code)))
  504.       (insert "Main:\n")
  505.       (setq ccl-current-ic 1)
  506.       (if (> (aref ccl-code 0) 0)
  507.       (progn
  508.         (while (< ccl-current-ic (aref ccl-code 0))
  509.           (ccl-dump-1))
  510.         (insert "At EOF:\n")))
  511.       (while (< ccl-current-ic len)
  512.     (ccl-dump-1))
  513.       ))
  514.   (display-buffer (get-buffer "*CCL-Dump*")))
  515.  
  516. (defun ccl-get-next-code ()
  517.   (prog1
  518.       (aref ccl-program-vector-dump ccl-current-ic)
  519.     (setq ccl-current-ic (1+ ccl-current-ic))))
  520.  
  521. (defun ccl-dump-1 ()
  522.   (let* ((opcode (ccl-get-next-code))
  523.      (code (logand opcode 31))
  524.      (cmd (aref ccl-machine-code-table code))
  525.      (rrr (logand (ash opcode -5) 7))
  526.      (cc (ash opcode -8)))
  527.     (insert (format "%4d: " (1- ccl-current-ic)))
  528.     (funcall (get cmd 'ccl-dump-function) rrr cc))) 
  529.  
  530. (defun ccl-dump-set-cs (rrr cc)
  531.   (insert (format "r%d = %s\n" rrr cc)))
  532.  
  533. (defun ccl-dump-set-cl (rrr cc)
  534.   (setq cc (ccl-get-next-code))
  535.   (insert (format "r%d = %s\n" rrr cc)))
  536.  
  537. (defun ccl-dump-set-r (rrr cc)
  538.   (insert (format "r%d = r%d\n" rrr cc)))
  539.  
  540. (defun ccl-dump-set-a (rrr cc)
  541.   (let ((range (ccl-get-next-code)) (i 0))
  542.     (insert (format "r%d = array[r%d] of length %d\n\t"
  543.             rrr cc range))
  544.     (let ((i 0))
  545.       (while (< i range)
  546.     (insert (format "%d " (ccl-get-next-code)))
  547.     (setq i (1+ i))))
  548.     (insert "\n")))
  549.  
  550. (defun ccl-dump-jump (rrr cc)
  551.   (insert (format "jump to %d\n" cc)))
  552.  
  553. (defun ccl-dump-jump-cond (rrr cc)
  554.   (insert (format "if !(r%d), jump to %d\n" rrr cc)))
  555.  
  556. (defun ccl-dump-write-jump (rrr cc)
  557.   (insert (format "write r%d, jump to %d\n" rrr cc)))
  558.  
  559. (defun ccl-dump-write-read-jump (rrr cc)
  560.   (insert (format "write r%d, read r%d, jump to %d\n" rrr rrr cc)))
  561.  
  562. (defun ccl-dump-write-c-jump (rrr cc)
  563.   (let ((const (ccl-get-next-code)))
  564.     (insert (format "write %s, jump to %d\n" const cc))))
  565.  
  566. (defun ccl-dump-write-c-read-jump (rrr cc)
  567.   (let ((const (ccl-get-next-code)))
  568.     (insert (format "write %s, read r%d, jump to %d\n" const rrr cc))))
  569.  
  570. (defun ccl-dump-write-s-jump (rrr cc)
  571.   (let ((len (ccl-get-next-code)) (i 0))
  572.     (insert "write \"")
  573.     (while (< i len)
  574.       (insert (format "%c" (ccl-get-next-code)))
  575.       (setq i (1+ i)))
  576.     (insert (format "\", jump to %d\n" cc))))
  577.  
  578. (defun ccl-dump-write-s-read-jump (rrr cc)
  579.   (let ((len (ccl-get-next-code)) (i 0))
  580.     (insert "write \"")
  581.     (while (< i len)
  582.       (insert (format "%c" (ccl-get-next-code)))
  583.       (setq i (1+ i)))
  584.     (insert (format "\", read r%d, jump to %d\n" rrr cc))))
  585.  
  586. (defun ccl-dump-write-a-read-jump (rrr cc)
  587.   (let ((len (ccl-get-next-code)) (i 0))
  588.     (insert (format "write array[r%d] of length %d, read r%d, jump to %d\n\t"
  589.             rrr len rrr cc))
  590.     (while (< i len)
  591.       (insert (format "%d " (ccl-get-next-code)))
  592.       (setq i (1+ i)))
  593.     (insert "\n")))
  594.  
  595. (defun ccl-dump-branch (rrr cc)
  596.   (let ((i 0))
  597.     (insert (format "jump to array[r%d] of length %d)\n\t" rrr cc))
  598.     (while (<= i cc)
  599.       (insert (format "%d " (ccl-get-next-code)))
  600.       (setq i (1+ i)))
  601.     (insert "\n")))
  602.  
  603. (defun ccl-dump-read1 (rrr cc)
  604.   (insert (format "read r%d\n" rrr)))
  605.  
  606. (defun ccl-dump-read2 (rrr cc)
  607.   (insert (format "read r%d and r%d\n" rrr cc)))
  608.  
  609. (defun ccl-dump-read-branch (rrr cc)
  610.   (insert (format "read r%d, " rrr))
  611.   (ccl-dump-branch rrr cc))
  612.  
  613. (defun ccl-dump-write1 (rrr cc)
  614.   (insert (format "write r%d\n" rrr)))
  615.  
  616. (defun ccl-dump-write2 (rrr cc)
  617.   (insert (format "write r%d and r%d\n" rrr cc)))
  618.  
  619. (defun ccl-dump-write-c (rrr cc)
  620.   (insert (format "write %s\n" (ccl-get-next-code))))
  621.  
  622. (defun ccl-dump-write-s (rrr cc)
  623.   (let ((len (ccl-get-next-code)) (i 0))
  624.     (insert "write \"")
  625.     (while (< i len)
  626.       (insert (format "%c" (ccl-get-next-code)))
  627.       (setq i (1+ i)))
  628.     (insert "\"\n")))
  629.  
  630. (defun ccl-dump-write-a (rrr cc)
  631.   (let ((len (ccl-get-next-code)) (i 0))
  632.     (insert (format "write array[r%d] of length %d\n\t" rrr len))
  633.     (while (< i 0)
  634.       (insert "%d " (ccl-get-next-code))
  635.       (setq i (1+ i)))
  636.     (insert "\n")))
  637.  
  638. (defun ccl-dump-end (rrr cc)
  639.   (insert "end\n"))
  640.  
  641. (defun ccl-dump-set-self-cs (rrr cc)
  642.   (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
  643.     (insert (format "r%d %s= %s\n" rrr arith cc))))
  644.  
  645. (defun ccl-dump-set-self-cl (rrr cc)
  646.   (setq cc (ccl-get-next-code))
  647.   (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
  648.     (insert (format "r%d %s= %s\n" rrr arith cc))))
  649.  
  650. (defun ccl-dump-set-self-r (rrr cc)
  651.   (let ((arith (aref ccl-arith-table (ccl-get-next-code))))
  652.     (insert (format "r%d %s= r%d\n" rrr arith cc))))
  653.  
  654. (defun ccl-dump-set-expr-cl (rrr cc)
  655.   (let ((const (ccl-get-next-code))
  656.     (arith (aref ccl-arith-table (ccl-get-next-code))))
  657.     (insert (format "r%d = r%d %s %s\n" rrr cc arith const))))
  658.  
  659. (defun ccl-dump-set-expr-r (rrr cc)
  660.   (let ((reg (ccl-get-next-code))
  661.     (arith (aref ccl-arith-table (ccl-get-next-code))))
  662.     (insert (format "r%d = r%d %s r%d\n" rrr cc arith reg))))
  663.  
  664. (defun ccl-dump-jump-cond-c (rrr cc)
  665.   (let ((const (ccl-get-next-code))
  666.     (arith (aref ccl-arith-table (ccl-get-next-code))))
  667.     (insert (format "if !(r%d %s %s), jump to %d\n" rrr arith const cc))))
  668.  
  669. (defun ccl-dump-jump-cond-r (rrr cc)
  670.   (let ((reg (ccl-get-next-code))
  671.     (arith (aref ccl-arith-table (ccl-get-next-code))))
  672.     (insert (format "if !(r%d %s r%d), jump to %d\n" rrr arith reg cc))))
  673.  
  674. (defun ccl-dump-read-jump-cond-c (rrr cc)
  675.   (insert (format "read r%d, " rrr))
  676.   (ccl-dump-jump-cond-c rrr cc))
  677.  
  678. (defun ccl-dump-read-jump-cond-r (rrr cc)
  679.   (insert (format "read r%d, " rrr))
  680.   (ccl-dump-jump-cond-r rrr cc))
  681.  
  682. ;; CCL emulation staffs 
  683.  
  684. ;; Not yet implemented.
  685.  
  686. ;; For byte-compiler
  687.  
  688. ;;;###autoload
  689. (defmacro define-ccl-program (name ccl-program &optional doc)
  690.   "Does (defconst NAME (ccl-compile (eval CCL-PROGRAM)) DOC).
  691. Byte-compiler expand this macro while compiling."
  692.   (` (defconst (, name) (, (ccl-compile (eval ccl-program))) (, doc))))
  693.  
  694. (put 'define-ccl-program 'byte-hunk-handler 'macroexpand)
  695.  
  696. (provide 'ccl)
  697.